{
Traviesadora beta 0.2.0.13.33 (30.11.2008)
LastMod: 05.02.2009 by Prof1983

Copyright 2004, Peter Millard

This file is part of Exodus.

Exodus is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

Exodus is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Exodus; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
}
unit Avatar;

interface

uses
  JabberSession, IQ, PNGImage,
  Unicode, JabberUtils, SecHash, Graphics, IdCoderMime, GifImage, Jpeg, XMLTag,
  Types, SysUtils, Classes, Dialogs, IdTCPConnection, IdTCPClient, IdHTTP, JabberConst;

const
  MAX_AVATAR_SIZE = 15000;

  PROF_EMAIL='email';
  PROF_URL='homepage';
  PROF_LOC_CITY='locality';
  PROF_LOC_CITY_CI='city';
  PROF_LOC_CITY_TO='town';
  PROF_LOC_CITY_VILL='village';

  PROF_COUNTRY='country';
  PROF_COUNTRY_NA='nation';

  PROF_NICK='nickname';
  PROF_NICK_AL='alias';

  PROF_GENDER='gender';
  PROF_GENDER_SE='sex';
  PROF_GENDER_ID='gender identification';

  PROF_BIRTHDAY_DAYOFMONTH='birth_dayofmonth';
  PROF_BIRTHDAY_MONTH='birth_month';
  PROF_BIRTHDAY_YEAR='birth_year';

  PROF_FAVTOY='fav_toy';
  PROF_TOYLIST='my_toys';
  PROF_DESC='description';

  PROF_EYECOLOR='eye_color';
  PROF_HAIRCOLOR='hair_color';
  PROF_HEIGHT='height';
  PROF_WEIGHT='weight';
  PROF_AVATAR='avatar_data';
  PROF_AVATAR_URL='avatar_url';

type
  TAvatarType = (avOLD, avCard);

  TAvatar = class
  public
    constructor Create();
    destructor Destroy(); override;
  private
    _pic: TGraphic;
    _hash: string;  // contains the sha1 hash
    _data: string;  // contains the base64 encoded image
    _iq: TJabberIQ;
    _height, _width: integer;

    procedure _genData();
    function getMimeType(): string;
  public
    jid: Widestring;
    AvatarType: TAvatarType;
    Valid: boolean;
    Pending: boolean;

    procedure SaveToFile(var filename: string);
    procedure SaveToStream(stream:TMemoryStream);
    procedure LoadFromFile(FileName: string);
    procedure Draw(c: TCanvas; r: TRect); overload;
    procedure Draw(c: TCanvas); overload;
    procedure parse(tag: TXMLTag);

    function  getHash(): string;
    function  isValid(): boolean;

    property  Data: string read _data;
    property  MimeType: string read getMimeType;
    property  Height: integer read _height;
    property  Width: integer read _width;
  end;

  TUserProfile = class
  public
    constructor Create(jSession: TJabberSession);
    destructor Destroy; override;

    procedure GetProfile(_tojid: string);
    procedure UpdateProfile;

    function empty: Boolean;

    function IsDownloading: Boolean;
    function IsUploading: Boolean;

    function GetAvatar: TAvatar;
    function GetEmail: string;
    function GetURL: string;
    function GetNick: string;
    function GetGender: string;
    function GetCity: string;
    function GetCountry: string;
    function GetBirthday: string;
    function GetFavToy: string;
    function GetToys: string;
    function GetDesc: string;
    function GetEyeColor: string;
    function GetHairColor: string;
    function GetWeight: string;
    function GetHeight: string;

    procedure SetEmail(t: string);
    procedure SetURL(t: string);
    procedure SetNick(t: string);
    procedure SetGender(t: string);
    procedure SetCity(t: string);
    procedure SetCountry(t: string);
    procedure SetBirthday(t: string);
    procedure SetFavToy(t: string);
    procedure SetToys(t: string);
    procedure SetDesc(t: string);
    procedure SetAvatar(a: TAvatar);
    procedure SetEyeColor(t: string);
    procedure SetHairColor(t: string);
    procedure SetWeight(t: string);
    procedure SetHeight(t: string);
    procedure SaveToFile(FileName: string);
    procedure LoadFromFile(FileName: string);
  private
    _jSession: TJabberSession;
    _profiletag: TXMLTag;

    _Email: string;
    _Url: string;
    _eyecolor: string;
    _haircolor: string;
    _weight: string;
    _height: string;
    _Nick: string;
    _Gender: string;
    _City: string;
    _Country: string;
    _Birthday: string;
    _FavToy: string;
    _Toys: string;
    _Desc: string;
    _Avatar: TAvatar;
    _tojid: string;
    _uploading: Boolean;
    _downloading: Boolean;
    _hash: string;
    procedure ParseTag(ptag: TXMLTag);

    procedure ProfileTXCallback(event: string; xml: TXMLTag);
    procedure VCardTXCallback(event: string; xml: TXMLTag);

    procedure ProfileRXCallback(event: string; xml: TXMLTag);
    procedure VCardRXCallback(event: string; xml: TXMLTag);
    function getHash: string;
  end;

  TAvatarCache = class
  private
    _cache: TWidestringlist;
    _session: TJabberSession;
    _pres1: integer;
    _pres2: integer;
    _sess: integer;

    _xp1: TXPLite;
    _xp2: TXPLite;

    _log: TStringlist;
    _ProfileName:string;
    procedure regCallbacks();
  protected
    procedure presCallback(event: string; tag: TXMLTag);
    procedure sessionCallback(event: string; tag: TXMLTag);
  public
    constructor Create(session:TJabberSession);
    destructor  Destroy(); override;

    procedure Clear();
    procedure setSession(session: TJabberSession);
    procedure Save();
    procedure Load(ProfileName:string);

    function Add(jid: Widestring; a: TUserProfile): integer;
    function Find(jid: Widestring): TUserProfile;
    procedure Remove(a: TUserProfile);

    procedure Log(tmps: string);
  end;

implementation

uses
  XMLParser, PrefController, JabberID, XmlvCard;

{ TAvatar }

constructor TAvatar.Create();
begin
  inherited;
  _pic := nil;
  _iq := nil;
  _hash := '';
  _data := '';
  Valid := false;
end;

destructor TAvatar.Destroy();
begin
  if (_pic <> nil) then FreeAndNil(_pic);
  inherited;
end;

procedure TAvatar.SaveToFile(var filename: string);
var
  base: string;
begin
  if (_pic = nil) then exit;

  base := ChangeFileExt(filename, '');
  try
    if (_pic is TGifImage) then
    begin
        filename := base + '.gif';
        TGifImage(_pic).SaveToFile(filename);
    end
    else if (_pic is TJPEGImage) then
    begin
        filename := base + '.jpg';
        TJPEGImage(_pic).SaveToFile(filename);
    end
    else if (_pic is TPNGObject) then
    begin
        filename := base + '.png';
        TPNGObject(_pic).SaveToFile(filename);
    end
    else
    begin
        filename := base + '.bmp';
        TBitmap(_pic).SaveToFile(filename);
    end;
  except
      // XXX: log save failure?
  end;
end;

procedure TAvatar.LoadFromFile(FileName: string);
var
  ext: string;
  IdHttp: TIdHttp;
  Stream: TStream;
  pictemp: TBitmap;
  factor: Single;
  r: TRect;
begin
  Valid := False;

  try
    ext := Lowercase(ExtractFileExt(filename));
    if (ext = '.gif') then
    begin
      _pic := TGifImage.Create();
      _pic.Transparent := true;
    end
    else if ((ext = '.jpg') or (ext = '.jpeg')) then
    begin
      _pic := TJpegImage.Create();
      _pic.Transparent := true;
    end
    else if (ext = '.png') then
    begin
      _pic := TPNGObject.Create();
      _pic.Transparent := true;
    end
    else if (ext = '.bmp') then
    begin
      _pic := TBitmap.Create();
      _pic.Transparent := true;
    end
    else
    begin
      if (_pic <> nil) then FreeAndNil(_pic);
    end;
    if Assigned(_pic) then
    begin
      if (Pos('http://', FileName) > 0) then
      begin
        IdHttp := TIdHTTP.Create(nil);
        Stream := TMemoryStream.Create();
        try
          IdHttp.Get(FileName, stream);
          _pic.LoadFromStream(stream);
        finally
          Stream.Free();
          IdHttp.Free();
        end;
      end
      else
      begin
        _pic.LoadFromFile(FileName);
      end;
      if ((_pic.Width > 256) or (_pic.height > 256)) then
      begin
        // resize
        if (_pic.Width >= _pic.Height) then
        begin
          factor := 256 / _pic.Width;
          r.Top := 0;
          r.Left := 0;
          r.Right := 256;
          r.Bottom := Round(_pic.Height * factor);
        end
        else
        begin
          factor := 256 / _pic.Height;
          r.Top := 0;
          r.Left := 0;
          r.Bottom := 256;
          r.Right := Round(_pic.Width * factor);
        end;
        pictemp := TBitmap.Create;
        try
          pictemp.Width := r.Right;
          pictemp.Height := r.Bottom;
          pictemp.Canvas.StretchDraw(r, _pic);
          FreeAndNil(_pic);
          _pic := TGIFImage.Create();
          (_pic as TGIFImage).ColorReduction := rmQuantize;
          (_pic as TGIFImage).Assign(pictemp);
          //(_pic as TGIFImage).SaveToFile('E:\test.gif');
        finally
          pictemp.free;
        end;
      end;
    end;
    _genData();
  except
    on invalid: EInvalidGraphic do
    begin
        MessageDlgW({_}('This grahpic cannot be loaded because it''s format isn''t supported. ' + chr(13) + chr(10) + '(Hint: Check that the file''s extension matches it''s type.)'),mtError, [mbOk], 0);
    end;
  end; // end try
end;

procedure TAvatar._genData();
var
  m: TMemoryStream;
  c: TIdEncoderMime;
begin
  _hash := '';
  _data := '';
  m := TMemoryStream.Create();
  if (_pic <> nil) then
      _pic.SaveToStream(m)
  else begin
      m.Free();
      exit;
  end;

  m.Position := 0;
  c := TIdEncoderMime.Create(nil);
  _data := c.Encode(m);
  c.Free();

  _height := _pic.Height;
  _width := _pic.Width;

  Valid := true;
end;

function TAvatar.getHash(): string;
var
  i: integer;
  m: TMemoryStream;
  hasher: TSecHash;
  h: TIntDigest;
  s: string;
begin
  if (_hash <> '') then begin
      Result := _hash;
      exit;
  end;

  m := TMemoryStream.Create();
  if (_pic <> nil) then
      _pic.SaveToStream(m)
  else begin
      m.Free();
      exit;
  end;
  m.Position := 0;
  hasher := TSecHash.Create(nil);
  h := hasher.ComputeMem(m.Memory, m.Size);
  for i := 0 to 4 do
      s := s + IntToHex(h[i], 8);
  _hash := Lowercase(s);

  m.Free();
  hasher.Free();
  Result := _hash;
end;

procedure TAvatar.Draw(c: TCanvas; r: TRect);
var
  aspect: single;
  rw, rh, pw, ph: integer;
begin
  if (_pic = nil) then exit;

  // draw while maintaing the aspect ratio
  ph := _pic.Height;
  pw := _pic.Width;

  rw := (r.Right - r.Left);
  rh := (r.Bottom - r.Top);

  // adjust the rectangle to ensure proper aspect control
  aspect := (ph / pw);

  if (aspect > 1.0) then begin
      rw := Round(rh / aspect);
      r.Right := r.Left + rw
  end
  else begin
      rh := Round(rw * aspect);
      r.Bottom := r.Top + rh;
  end;

  // draw
  c.StretchDraw(r, _pic);
end;

procedure TAvatar.Draw(c: TCanvas);
begin
  if (_pic = nil) then exit;
  c.Draw(1, 1, _pic);
end;

procedure TAvatar.parse(tag: TXMLTag);
var
  mtype, bv: TXMLTag;
  data, mt: Widestring;
  m: TMemoryStream;
  d: TIdDecoderMime;
  i: integer;
  tmps: TWidestringList;
begin
  Valid := false;
  if (_pic <> nil) then FreeAndNil(_pic);

  // check for cdata attached directly to <PHOTO>
  data := tag.Data;
  if (trim(data) = '') then begin
      // check for <BINVAL>...</BINVAL>
      bv := tag.GetFirstTag('BINVAL');
      if (bv <> nil) then
          data := bv.Data;
  end;

  // if we have no data, then bail
  if (trim(data) = '') then exit;

  tmps := TWidestringList.Create();
  split(data, tmps);
  _data := '';
  for i := 0 to tmps.Count - 1 do begin
      _data := _data + tmps[i];
  end;

  m := TMemoryStream.Create();
  d := TIdDecoderMime.Create(nil);
  try
      d.DecodeToStream(_data, m);
      m.Position := 0;

      mtype := tag.GetFirstTag('TYPE');
      if (mtype = nil) then
          mtype := tag.GetFirstTag('type');
      if (mtype <> nil) then
          mt := mtype.Data
      else begin
          mt := tag.GetAttribute('mimetype');
          if (mt = '') then mt := tag.GetAttribute('mime-type');
          if (mt = '') then mt := tag.GetAttribute('type');
      end;

      if (mt = 'image/gif') then begin
          _pic := TGifImage.Create();
          _pic.Transparent := true;
          _pic.LoadFromStream(m);
          _genData();
      end
      else if (mt = 'image/jpeg') then begin
          _pic := TJPEGImage.Create();
          _pic.Transparent := true;
          _pic.LoadFromStream(m);
          _genData();
      end
      else if (mt = 'image/x-ms-bmp') or (mt = 'image/bmp') then begin
          _pic := TBitmap.Create();
          _pic.Transparent := true;
          _pic.LoadFromStream(m);
          _genData();
      end
      else if (mt = 'image/png') then begin
          _pic := TPNGObject.Create();
          _pic.Transparent := true;
          _pic.LoadFromStream(m);
          _genData();
      end
      else if (_data <> '') then begin
          try
              _pic := TJPEGImage.Create();
              _pic.Transparent := true;
              _pic.LoadFromStream(m);
              _genData();
          except
              try
                  FreeAndNil(_pic);
                  m.Position := 0;
                  _pic := TGifImage.Create();
                  _pic.Transparent := true;
                  _pic.LoadFromStream(m);
                  _genData();
              except
                  try
                      // XXX: try PNG?

                      FreeAndNil(_pic);
                      m.Position := 0;
                      _pic := TBitmap.Create();
                      _pic.Transparent := true;
                      _pic.LoadFromStream(m);
                      _genData();
                  except
                      FreeAndNil(_pic);
                  end;
              end;
          end;
      end;
  except
      if (_pic <> nil) then FreeAndNil(_pic);
  end;

  m.Free();
  d.Free();
end;

{procedure TAvatar.fetch(session: TJabberSession);
var
    tmpjid: TJabberID;
begin
    //
    tmpjid := TJabberID.Create(jid);
    assert(_iq = nil);
    assert(jid <> '');
    _iq := TJabberIQ.Create(session, session.generateID(), fetchCallback);
    _iq.iqType := 'get';
    Pending := true;

    if (AvatarType = avOld) then begin
        _iq.Namespace := 'jabber:iq:avatar';
        _iq.toJid := tmpjid.full;
        _iq.Send();
    end
    else begin
        _iq.qTag.Name := 'vCard';
        _iq.Namespace := XMLNS_VCARD;
        _iq.toJid := tmpjid.jid;
        _iq.Send();
    end;
    tmpjid.Free();
end;         }

{procedure TAvatar.fetchCallback(event: string; tag: TXMLTag);
var
    tmps: string;
    tmpjid: TJabberID;
    q, d, x: TXMLTag;
    old: TAvatar;
begin
    _iq := nil;
    Pending := false;
    if (event <> 'xml') then exit;

    if (AvatarType = avOld) then begin
        q := tag.GetFirstTag('query');
        if (q <> nil) then begin
            d := q.GetFirstTag('data');
            if (d <> nil) then Parse(d);
        end;
    end
    else begin
        q := tag.GetFirstTag('vcard');
        if (q = nil) then
            q := tag.GetFirstTag('VCARD');
        if (q = nil) then
            q := tag.GetFirstTag('vCard');
        if (q = nil) then
            q := tag.GetFirstTag('query');

        if (q <> nil) then begin
            d := q.GetFirstTag('PHOTO');
            if (d <> nil) then Parse(d);
        end;
    end;

    if (Valid) then begin
        tmpjid := TJabberID.Create(jid);
        old := Avatars.Find(tmpjid.jid);
        if (old = Self) then 
            // do nothing
        else if (old <> nil) then begin
            Avatars.Remove(old);
            old.Free();
            Avatars.Add(tmpjid.jid, Self);
        end
        else
            Avatars.Add(tmpjid.jid, Self);

        // Save the cache
        Avatars.Save();

        {$ifdef Exodus}
{        tmps := 'AVATAR CB: ' + tmpjid.jid + ', HASH: ' + getHash();
        Avatars.Log(tmps);
        {$endif}
{
        x := TXMLTag.Create('avatar');
        x.setAttribute('jid', tmpjid.jid);
        MainSession.FireEvent('/session/avatars', x);

        tmpjid.Free();
    end;
end;     }

function TAvatar.getMimeType(): string;
begin
  if (_pic = nil) then
      Result := 'INVALID'
  else if (Valid = false) then
      Result := 'INVALID'
  else if (_pic is TGifImage) then
      Result := 'image/gif'
  else if (_pic is TJPEGImage) then
      Result := 'image/jpeg'
  else if (_pic is TBitmap) then
      Result := 'image/x-ms-bmp'
  else if (_pic is TPNGObject) then
      Result := 'image/png'
  else
      Result := 'INVALID';
end;

function TAvatar.isValid(): boolean;
begin
  Result := (_pic <> nil);
end;

{ TAvatarCache }

constructor TAvatarCache.Create(session:TJabberSession);
begin
  inherited Create;
  _cache := TWidestringlist.Create();
  _log := TStringlist.Create();
  _session := session;
  _xp1 := TXPLite.Create('/presence/x[@xmlns="jabber:x:avatar"]');
  _xp2 := TXPLite.Create('/presence/x[@xmlns="vcard-temp:x:update"]');
  _pres1 := -1;
  _pres2 := -1;
  _sess := -1;
end;

destructor  TAvatarCache.Destroy();
begin
  Clear();

  _cache.Free();
  _log.Free();

  _xp1.Free();
  _xp2.Free();

  inherited;
end;

procedure TAvatarCache.Log(tmps: string);
begin
  //_log.Add(tmps);
  //_log.SaveToFile('c:\temp\avatars.txt');
end;

function TAvatarCache.Add(jid: Widestring; a: TUserProfile): integer;
var
  o: TUserProfile;
  i: integer;
begin
  i := _cache.IndexOf(jid);
  if (i >= 0) then begin
      o := TUserProfile(_cache.Objects[i]);
      if (o <> a) then begin
          o.Free();
          _cache.Objects[i] := a;
      end;
  end
  else begin
      i := _cache.AddObject(jid, a);
  end;

  Result := i;
end;

procedure TAvatarCache.Remove(a: TUserProfile);
var
  idx: integer;
begin
  idx := _cache.IndexOfObject(a);
  if (idx >= 0) then
      _cache.Delete(idx);
end;

procedure TAvatarCache.Clear();
var
  u: TUserProfile;
begin
  while (_cache.Count > 0) do
  begin
      u := TUserProfile(_cache.Objects[0]);
      if u <> nil then
        u.destroy();
      _cache.Delete(0);
  end;
end;

function TAvatarCache.Find(jid: Widestring): TUserProfile;
var
  i: integer;
begin
  i := _cache.IndexOf(jid);
  if (i >= 0) then
      Result := TUserProfile(_cache.Objects[i])
  else
      Result := nil;
end;

procedure TAvatarCache.regCallbacks();
begin
  if ((_session.Prefs.getBool('roster_avatars') = false) and
      (_session.Prefs.getBool('chat_avatars') = false)) then
  begin
      // turn off callbacks
      if (_pres1 <> -1) then
      begin
          _session.UnRegisterCallback(_pres1);
          _session.UnRegisterCallback(_pres2);
          _pres1 := -1;
          _pres2 := -1;
      end;
  end
  else
  begin
      // turn on callbacks
      if (_pres1 = -1) then
      begin
          _pres1 := _session.RegisterCallback(presCallback,
              '/packet/presence/x[@xmlns="vcard-temp:x:update"]');
          _pres2 := _session.RegisterCallback(presCallback,
              '/packet/presence/x[@xmlns="jabber:x:avatar"]');
      end;
  end;
end;

procedure TAvatarCache.setSession(session: TJabberSession);
begin
  {_session := session;
  _sess := _session.RegisterCallback(sessionCallback, '/session');
  regCallbacks();
  Load();   }
end;

procedure TAvatarCache.presCallback(event: string; tag: TXMLTag);
{var
  tmps: string;
  fetch: boolean;
  a: TAvatar;
  fjid: TJabberID;
  hash: Widestring;
  x1: TXMLTag;
  x2: TXMLTag;}
begin
  // we got an avatar enabled presence
{  fetch := false;
  fjid := TJabberID.Create(tag.getAttribute('from'));

  x1 := tag.QueryXPTag(_xp1);
  x2 := tag.QueryXPTag(_xp2);

  if (x2 <> nil) then
      // iChat mode
      hash := x2.GetBasicText('photo')
  else
      // old iq:avatar mode
      hash := x1.GetBasicText('hash');

  // bail if we have no hash value
  if (Trim(hash) = '') then exit;

  assert((x1 <> nil) or (x2 <> nil));

  {$ifdef Exodus}
{   tmps := 'AVATAR: ' + fjid.jid + ', HASH: ' + hash;
  Log(tmps);
  {$endif}
{
  a := find(fjid.jid);
  if (a = nil) then begin
      fetch := true;
      a := TAvatar.Create();
      a.jid := fjid.jid;
      _cache.AddObject(fjid.jid, a);
  end
  else begin
      // compare hashes
      if (a.Pending) then
          fetch := false
      else if (hash <> a.getHash()) then begin
          fetch := true;
      end;
  end;

  if (fetch) then begin
      a.jid := fjid.full;
      if (x2 <> nil) then
          a.AvatarType := avCard
      else
          a.AvatarType := avOld;
      a.Fetch(_session);
  end;

  fjid.Free();  }
end;

procedure TAvatarCache.sessionCallback(event: string; tag: TXMLTag);
begin
  if (event = '/session/disconnected') then
      Save()
  else if (event = '/session/prefs') then
      regCallbacks();
end;

procedure TAvatarCache.Load(ProfileName:string);
var
  //tmps: string;
  a: TUserProfile;
  i: integer;
  jid: Widestring;
  name, path, fn: string;
  p: TXMLTagParser;
  root, t: TXMLTag;
  items: TXMLTagList;
begin
  _ProfileName := ProfileName;
  path := GetApplicationPath +'cache\'+ _ProfileName+'\avatars';
  if (DirectoryExists(path) = false) then exit;

  fn := path + '\cache.xml';
  if (FileExists(fn)) then
  begin
    p := TXMLTagParser.Create();
    p.ParseFile(fn);
    root := p.popTag();
    if (root <> nil) then
    begin
      items := root.QueryTags('item');
      for i := 0 to items.Count - 1 do
      begin
        t := items[i];
        name := t.GetAttribute('name');
        jid := t.GetAttribute('jid');
        if ((jid <> '') and (name <> '') and (FileExists(name))) then
        begin
          a := TUserProfile.Create(_session);
          a.LoadFromFile(name);
          a._tojid := jid;
          _cache.AddObject(jid, a);
          {$ifdef Exodus}
          //tmps := 'LOAD: ' + jid + ', HASH: ' + a.getHash();
          //Log(tmps);
          {$endif}
        end;
      end;
      items.Free();
      root.Free();
    end;
    p.Free();
  end;
end;

procedure TAvatarCache.Save();
var
  i: integer;
  a: TUserProfile;
  fn, path, name: string;
  root, t: TXMLTag;
  s: TWidestringlist;
begin
  path := GetApplicationPath + 'cache\'+_ProfileName+'\avatars';
 // path := getUserDir() + 'avatars';
  if (DirectoryExists(path) = false) then
      ForceDirectories(path);
  if (DirectoryExists(path) = false) then exit;

  fn := path + '\cache.xml';

  root := TXMLTag.Create('cache');
  for i := 0 to _cache.Count - 1 do begin
      a := TUserProfile(_cache.Objects[i]);
      name := path + '\' + a.getHash();
      a.SaveToFile(name);
      t := root.AddTag('item');
      t.setAttribute('name', name);
      t.setAttribute('jid', _cache[i]);
  end;

  s := TWidestringlist.Create();
  s.Add(root.xml);
  s.SaveToFile(fn);
  s.Free();

  root.Free();
end;

{ TUserProfile }

constructor TUserProfile.create(jSession:TJabberSession);
begin
  inherited create;
  Self._jSession := jSession;
  _profiletag := nil;
  _uploading:=false;
  _downloading:=false;
  _hash := '';
end;

destructor TUserProfile.destroy;
begin
  if _Avatar <> nil then
    FreeAndNil(_Avatar);
  if _profiletag <> nil then
    FreeAndNil(_profiletag);
  inherited destroy;
end;

function TUserProfile.getHash(): string;
var
  i: integer;
  m: TMemoryStream;
  hasher: TSecHash;
  h: TIntDigest;
  s: string;
  t: string;
  //buffer:string;
begin
  if (_hash <> '') then
  begin
    Result := _hash;
    exit;
  end;

  m := TMemoryStream.Create();
  if (_Avatar <> nil) then
      _Avatar.SaveToStream(m)
  else
  begin
     // m.Free();
     // exit;
  end;
 // t := _tojid;        m.WriteBuffer(t,length(t));
  t := GetBirthday;   m.WriteBuffer(t,length(t));
  t := GetEmail;      m.WriteBuffer(t,length(t));
  t := GetCity;       m.WriteBuffer(t,length(t));
  t := GetCountry;    m.WriteBuffer(t,length(t));
  t := GetDesc;       m.WriteBuffer(t,length(t));
  t := GetEyeColor;   m.WriteBuffer(t,length(t));
  t := GetFavToy;     m.WriteBuffer(t,length(t));
  t := GetGender;     m.WriteBuffer(t,length(t));
  t := GetHairColor;  m.WriteBuffer(t,length(t));
  t := GetHeight;     m.WriteBuffer(t,length(t));
  t := GetNick;       m.WriteBuffer(t,length(t));
  t := GetToys;       m.WriteBuffer(t,length(t));
  t := GetURL;        m.WriteBuffer(t,length(t));
  t := GetWeight;     m.WriteBuffer(t,length(t));
  m.Position := 0;
  hasher := TSecHash.Create(nil);
  h := hasher.ComputeMem(m.Memory, m.Size);
  for i := 0 to 4 do
      s := s + IntToHex(h[i], 8);
  _hash := Lowercase(s);

  m.Free();
  hasher.Free();
  Result := _hash;
end;

procedure TUserProfile.SaveToFile(fileName: string);
var
  vcard: TXMLVcard;
begin
  vcard := TXMLVCard.Create;
  try
    with vcard do
    begin
      email := _Email;
      url := _Url;
      // _eyecolor;
      //_haircolor;
      //_weight;
      //_height;
      nick := _Nick;
      gender := _Gender;
    // Home := TXMLVCardAddress.Create;
      Home.Locality := _City;
      Home.Country := _Country;
      bday  :=  _Birthday;
      fav_toy :=  _FavToy;
      my_toys := _Toys;
      desc_pr :=  _Desc;
      Picture :=_Avatar;
    end;
    vcard.savetofile(filename);
  finally
    vcard.Free;
  end;
end;

procedure TUserProfile.LoadFromFile(filename: string);
var
  vcard: TXMLVCard;
  //tag: TXMLTag;
begin
  vcard := TXMLVCard.Create;
  try
    vcard.LoadFromFile(filename);
    if _Email = '' then
      _Email := vcard.email;
    if _Nick = '' then
      _Nick := vcard.nick;
    if _Birthday = '' then
      _Birthday := vcard.bday;
    if _Url = '' then
      _Url := vcard.url;
    if _Desc = '' then
      _Desc := vcard.desc_pr;
    if _FavToy = '' then
      _FavToy := vcard.fav_toy;
    if _Toys = '' then
      _toys := vcard.my_toys;
    if _City = '' then
      _City := vcard.Home.Locality;
    if _Country = '' then
      _Country := vcard.Home.Country;
    if _Gender = '' then
      _Gender := vcard.gender;
    _Avatar := vcard.Picture;
  finally
    vcard.Free;
  end;
end;

procedure TUserProfile.UpdateProfile;
var
  iq: TJabberIQ;
  //tag: TXMLTag;
  t1: TXMLTag;
  t2: TXMLTag;
  day: string;
  month: string;
  year: string;
begin
  _uploading := true;
  iq := TJabberIQ.Create(_jSession, _jSession.generateID, ProfileTXCallback,AUTH_TIMEOUT);
  with iq do
  begin
    Namespace := XMLNS_PROFILE;
    iqType := 'set';
    qTag.Name := 'profile';
    qTag.setAttribute('xmlns',XMLNS_PROFILE);
    t1 := qTag.AddTag('x');
    t1.setAttribute('xmlns','jabber:x:data');
    t1.setAttribute('type','submit');
    t2 := t1.AddTag('field');
    t2.setAttribute('var','FORM_TYPE');
    t2.setAttribute('type','hidden');
    t2.AddBasicTag('value','urn:xmpp:tmp:profile');

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_EMAIL);
    t2.AddBasicTag('value',_Email);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_URL);
    t2.AddBasicTag('value',_Url);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_EYECOLOR);
    t2.AddBasicTag('value',_eyecolor);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_HAIRCOLOR);
    t2.AddBasicTag('value',_haircolor);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_WEIGHT);
    t2.AddBasicTag('value',_weight);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_HEIGHT);
    t2.AddBasicTag('value',_height);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_NICK);
    t2.AddBasicTag('value',_Nick);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_GENDER);
    t2.AddBasicTag('value',_Gender);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_LOC_CITY);
    t2.AddBasicTag('value',_City);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_COUNTRY);
    t2.AddBasicTag('value',_Country);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_FAVTOY);
    t2.AddBasicTag('value',_FavToy);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_TOYLIST);
    t2.AddBasicTag('value',_Toys);

    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_DESC);
    t2.AddBasicTag('value',_Desc);

    day := _Birthday;
    delete(day,pos('.',day),length(day));
    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_BIRTHDAY_DAYOFMONTH);
    t2.AddBasicTag('value',day);

    month := _Birthday;
    delete(month,1,pos('.',month));
    delete(month,pos('.',month),length(month));
    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_BIRTHDAY_MONTH);
    t2.AddBasicTag('value',month);

    year := _Birthday;
    delete(year,1,pos('.',year));
    delete(year,1,pos('.',year));
    t2 := t1.AddTag('field');
    t2.setAttribute('var',PROF_BIRTHDAY_YEAR);
    t2.AddBasicTag('value',year);
  end;
  iq.Send;
end;

procedure TUserProfile.GetProfile(_tojid: string);
{var
  iq: TJabberIQ;}
begin
  _Email:='';
  _Url:='';
  _eyecolor:='';
  _haircolor:='';
  _weight:='';
  _height:='';
  _Nick:='';
  _Gender:='';
  _City:='';
  _Country:='';
  _Birthday:='';
  _FavToy:='';
  _Toys:='';
  _Desc:='';
  _downloading := true;
  if Assigned(_Avatar) then
    FreeAndNil(_avatar);

  self._tojid := _tojid;
  ProfileRXCallback('', nil);
 { iq := TJabberIQ.Create(_jSession, _jSession.generateID, ProfileRXCallback,5);
  with iq do begin
      iqType := 'get';
      toJid := _tojid;
      fromJid := _jSession.Jid;
        Namespace := XMLNS_PROFILE;
      with qTag do begin
        name:='profile';
      end;
  end;
  iq.Send;  }
end;

procedure TUserProfile.ProfileTXCallback(event: string; xml: TXMLTag);
var
  IQ: TJabberIQ;
  vcard: TXMLVcard;
begin
  vcard := TXMLVCard.Create;
  with vcard do
  begin
    email := _Email;
    url := _Url;
    // _eyecolor;
    //_haircolor;
    //_weight;
    //_height;
    nick := _Nick;
    gender := _Gender;
   // Home := TXMLVCardAddress.Create;
    Home.Locality := _City;
    Home.Country := _Country;
    bday  :=  _Birthday;
    fav_toy :=  _FavToy;
    my_toys := _Toys;
    desc_pr :=  _Desc;
    Picture :=_Avatar;
  end;

  iq := TJabberIQ.Create(_jSession, _jSession.generateID, VCardTXCallback,AUTH_TIMEOUT);
  with iq do
  begin
    iqType := 'set';
    Namespace := XMLNS_VCARD;
    with qTag do
    begin
      name := 'vCard';
      vcard.filltag(qTag,false);
    end;
  end;
  iq.Send;
end;

procedure TUserProfile.VCardTXCallback(event: string; xml: TXMLTag);
begin
  if xml.GetAttribute('type') = 'result' then
  begin
    _jSession.FireEvent('/session/error/profile_submitted',xml);
    _uploading := false;
  end
  else if (xml.GetAttribute('type') = 'error') then
  begin
    _jSession.FireEvent('/session/error/profile_submitted',xml);
    _uploading := false;
  end;
end;

procedure TUserProfile.ParseTag(ptag: TXMLTag);
var
  fieldtag: TXMLTag;
  i: Integer;
  s: string;
  month: string;
  day: string;
  year: string;
begin
  month := 'xx';
  day := 'xx';
  year := 'xxxx';
  for i := 0 to ptag.ChildCount-1 do
  begin
    fieldtag := ptag.ChildTags.Tags[i];
    s := Lowercase(fieldtag.GetAttribute('var'));
    fieldtag := ptag.GetFirstTag('value');
    if Assigned(fieldtag) then
    begin
      if s = PROF_EMAIL then
      begin
        _Email := fieldtag.XML;
      end
      else if s = PROF_URL then
      begin
        _Url := fieldtag.XML;
      end
      else if (s = PROF_LOC_CITY) or (s=PROF_LOC_CITY_CI)or(s=PROF_LOC_CITY_TO)or(s=PROF_LOC_CITY_VILL) then
      begin
        _City := fieldtag.XML;
      end
      else if (s=PROF_COUNTRY)or(s=PROF_COUNTRY_NA) then
      begin
        _Country := fieldtag.XML;
      end
      else if (s=PROF_NICK)or (s=PROF_NICK_AL) then
      begin
        _Nick := fieldtag.XML;
      end
      else if (s=PROF_GENDER)or (s=PROF_GENDER_SE)or (s=PROF_GENDER_ID) then
      begin
        _Gender := fieldtag.XML;
      end
      else if (s=PROF_BIRTHDAY_DAYOFMONTH) then
      begin
        day := fieldtag.XML;
      end
      else if (s=PROF_BIRTHDAY_MONTH) then
      begin
        month := fieldtag.XML;
      end
      else if (s=PROF_BIRTHDAY_YEAR) then
      begin
        year := fieldtag.XML;
      end
      else if (s=PROF_FAVTOY) then
      begin
        _FavToy := fieldtag.XML;
      end
      else if (s=PROF_TOYLIST) then
      begin
        _Toys := fieldtag.XML;
      end
      else if (s=PROF_DESC) then
      begin
        _Desc := fieldtag.XML;
      end
      else if (s=PROF_EYECOLOR) then
      begin
        _eyecolor := fieldtag.XML;
      end
      else if (s=PROF_HAIRCOLOR) then
      begin
        _haircolor := fieldtag.XML;
      end
      else if (s=PROF_HEIGHT) then
      begin
        _height := fieldtag.XML;
      end
      else if (s=PROF_weight) then
      begin
        _weight := fieldtag.XML;
      end
      else if (s=PROF_AVATAR) then
      begin
      end
      else if (s=PROF_AVATAR_URL) then
      begin
        _Avatar := TAvatar.Create;
        _Avatar.LoadFromFile(fieldtag.XML);
      end;
    end;
  end;
  _Birthday := day+'.'+month+'.'+year;
end;

procedure TUserProfile.ProfileRXCallback(event: string; xml: TXMLTag);
var
  tag: TXMLTag;
  iq: TJabberIQ;
begin
  if Assigned(xml) then
  begin
    if xml.GetAttribute('type') = 'result' then
    begin
      tag := xml.GetFirstTag('profile');
      if tag <> nil then
      begin
        _profiletag := tag.GetFirstTag('x');
        ParseTag(_profiletag);
      end;
      //_jSession.FireEvent('/session/profile',xml);
    end else if (xml.GetAttribute('type') = 'error') then begin
      //_jSession.FireEvent('/session/error/profile',xml);
    end;
  end;
  iq := TJabberIQ.Create(_jSession, _jSession.generateID(), VCardRXCallback,AUTH_TIMEOUT);
  with iq do begin
    Namespace := XMLNS_VCARD;
    qTag.Name := 'vCard';
    iqType := 'get';
    toJid := _tojid;
    Send;
  end;
end;

procedure TUserProfile.VCardRXCallback(event: string; xml: TXMLTag);
var
  vcard: TXMLVCard;
  //tag: TXMLTag;
begin
  if xml = nil then
  begin
    _jSession.FireEvent('/session/profile_next',xml);
    Exit;
  end;
  if xml.GetAttribute('type') = 'result' then
  begin
    vcard := TXMLVCard.Create;
    try
      vcard.Parse(xml);
      if _Email = '' then
        _Email := vcard.email;
      if _Nick = '' then
        _Nick := vcard.nick;
      if _Birthday = '' then
        _Birthday := vcard.bday;
      if _Url = '' then
        _Url := vcard.url;
      if _Desc = '' then
        _Desc := vcard.desc_pr;
      if _FavToy = '' then
        _FavToy := vcard.fav_toy;
      if _Toys = '' then
        _toys := vcard.my_toys;
      if _City = '' then
        _City := vcard.Home.Locality;
      if _Country = '' then
        _Country := vcard.Home.Country;
      if _Gender = '' then
        _Gender := vcard.gender;
      _Avatar := vcard.Picture;
      _jSession.FireEvent('/session/profile_rxed',xml);
      _jSession.FireEvent('/session/profile_next',xml);
      _downloading := false;
    finally
      vcard.Free;
    end;
  end
  else if (xml.GetAttribute('type') = 'error') then
  begin
    _jSession.FireEvent('/session/error/profile_rxed',xml);
    _jSession.FireEvent('/session/profile_next',xml);
    _downloading := false;
  end;
end;

function TUserProfile.GetAvatar(): TAvatar;
begin
  Result := _Avatar;
end;

function TUserProfile.GetBirthday: string;
begin
  Result := _Birthday;
end;

function TUserProfile.GetCity: string;
begin
  result := _City;
end;

function TUserProfile.GetCountry: string;
begin
  result := _country;
end;

function TUserProfile.GetDesc: string;
begin
  result := _Desc;
end;

function TUserProfile.GetEmail: string;
begin
  result := _Email
end;

function TUserProfile.GetFavToy: string;
begin
  result := _FavToy;
end;

function TUserProfile.GetGender: string;
begin
  result := _Gender;
end;

function TUserProfile.GetNick: string;
begin
  result := _Nick;
end;

function TUserProfile.GetToys: string;
begin
  Result := _Toys;
end;

function TUserProfile.GetURL: string;
begin
  result := _url;
end;

function TUserProfile.GetEyeColor: string;
begin
  result := _eyecolor;
end;

function TUserProfile.GetHairColor: string;
begin
  result := _haircolor;
end;

function TUserProfile.GetHeight: string;
begin
  result := _height;
end;

function TUserProfile.GetWeight: string;
begin
  result := _weight;
end;

procedure TUserProfile.SetAvatar(a: TAvatar);
begin
  _Avatar := a;
end;

procedure TUserProfile.SetBirthday(t: string);
begin
  _Birthday := t;
end;

procedure TUserProfile.SetCity(t: string);
begin
  _City := t;
end;

procedure TUserProfile.SetCountry(t: string);
begin
  _Country := t;
end;

procedure TUserProfile.SetDesc(t: string);
begin
  _Desc := t;
end;

procedure TUserProfile.SetEmail(t: string);
begin
  _Email := t;
end;

procedure TUserProfile.SetEyeColor(t: string);
begin
  _eyecolor := t;
end;

procedure TUserProfile.SetFavToy(t: string);
begin
  _FavToy := t;
end;

procedure TUserProfile.SetGender(t: string);
begin
  _Gender := t;
end;

procedure TUserProfile.SetHairColor(t: string);
begin
  _haircolor := t;
end;

procedure TUserProfile.SetHeight(t: string);
begin
  _height := t;
end;

procedure TUserProfile.SetNick(t: string);
begin
  _Nick := t;
end;

procedure TUserProfile.SetToys(t: string);
begin
  _Toys := t;
end;

procedure TUserProfile.SetURL(t: string);
begin
  _Url := t;
end;

procedure TUserProfile.SetWeight(t: string);
begin
  _weight := t;
end;

function TUserProfile.IsDownloading: boolean;
begin
  result := _downloading;
end;

function TUserProfile.IsUploading: boolean;
begin
  result := _uploading;
end;

procedure TAvatar.SaveToStream(stream: TMemoryStream);
begin
  if Assigned(_pic) then
    _pic.SaveToStream(stream);
end;

function TUserProfile.empty(): Boolean;
begin
  Result := (_Email = '') and (_Url = '') and (_eyecolor = '') and (_haircolor = '') and (_weight = '')
               and (_height = '' )and (_Nick = '') and (_Gender = '') and (_City = '') and   (_Country = '') and
                (_Birthday = '') and (_FavToy = '' )and (_Toys = '' )and (_Desc = '') and (_Avatar = nil );
end;

end.
